perm filename CRESC.F4[P11,LCS] blob
sn#579537 filedate 1981-04-15 generic text, type T, neo UTF8
C****** CRESC.F4 ---- HEAVY, HBRACK, CBRACK, RPDOT -----
SUBROUTINE CRESC
C DRAWS CRESC. AND RECTANGLES *****
IMPLICIT INTEGER(A-Q,S-Z)
REAL OLDY,STFF,XDIS
COMMON /STF/RSTFAC(0/7),RSTJ2 /MIN/MINI,RMINI
COMMON R2,JA,CENTR,J2,RJQ(20),JQ(16) /BM/RA,RC,RJY
COMMON /POSI/STFF(0/7),JJ2,POS /PLTR/PLT,RHT,DIS,XDIS
COMMON /ALF/QQ(3),RST7,RST18,R3Q,JY,RD,RX,RW,RJX,RJ,L,K,
1 RJA,YY,DISX,HGT,RZ,INP(53) /OLDTOP/OLDY
EQUIVALENCE (R11,RJQ(9)),(R6,RJQ(4)),(J8,JQ(6)),(J10,JQ(8))
1,(R9,RJQ(7)),(R8,RJQ(6)),(R3,RJQ(1)),(R7,RJQ(5)),(R4,RJQ(2))
300 IF(R7.EQ.0)R7=2.3
IF(R7.EQ.-1.)R7=-2.3
RA=ABS(R7/2.0)*RST7
C AMOUNT OF SPREAD
RJ=R3Q
RX=RX-RST18+RD
IF(R8.NE.0)GO TO 302
C JUMP TO MAKE BOX
R6=RHORZ(R6)
IF(R7.LT.0)GO TO 301
RJ=R6
R6=R3Q
301 CALL LINX(RJ,RA+RX,R6,RX)
CALL LINES(RJ,RX-RA,2)
C FOR CRESC, DECRESC:4 POS1, STF, HGT, 50, POS1, +OR-N(0=2.3,-1=-2.3)
IF(PLT.GE.0)RETURN
C THIS MAKES ALL CRESC. DBL THICKNESS AT PRINT TIME.
IF(J8.LT.0)RETURN
RX=RX+XDIS
J8=-1
C FOR DOUBLE THICKNESS
GO TO 301
302 R8=R8*RST7
R9=R9*RST7
IF(R9.EQ.0)R9=R8
C R9=0 MAKES SQUARE
R3=R3Q-R8/2.
RX=RX-R9/2.
OLDY=RX
IF(R11.NE.0)OLDY=OLDY+R11*RST7
C R11 IS OFFSET FOR PARALLELAGRAM
C DRAWS BOX, CENTER IS IN MIDDLE
C 4,POSI+=9,STF,NT#,50,0,0,,SIZ1↑BY NT#S↑,SIZ2
1302 CALL LINX(R3,RX,R3+R8,OLDY)
CALL LINES(R3+R8,OLDY+R9,2)
CALL LINES(R3,RX+R9,2)
CALL LINES(R3,RX,2)
IF(J10.EQ.0)RETURN
J10=J10-1
RJ=XDIS
R3=R3-RJ
R8=R8+RJ+RJ
RX=RX-RJ
OLDY=OLDY-RJ
R9=R9+RJ+RJ
GO TO 1302
C TO THICKEN BOXES.
END
SUBROUTINE HEAVY
COMMON R2,JA,CENTR,J2,RJQ(20),JQ(16) /BM/RA,RC,RJY
COMMON /ALF/QQ(3),RST7,RST18,R3Q,JY,RD,RX,RW,RJX,RJ,L,K,
1 RJA,YY,DISX,HGT,RZ,INP(53) /OLDTOP/OLDY
EQUIVALENCE (R6,RJQ(4)),(J10,JQ(8)),(J7,JQ(5))
C FOR 'HEAVY' LINE.
C P10 = NUM. OF ADDITIONAL LINES.
C ****** ONLY GOOD FOR SLOPE OF LESS THAN 45 DEG.
J7=J7-1
J10=J7
C GET SHIFT INCREMENT (DEPENDS ON FINAL SIZE)
RR=ABS(RX-OLDY)
C RR HAS AMOUNT OF Y SHIFT IN LINE
RQ=ABS(R3Q-RJX)
C RQ HAS AMOUNT OF X SHIFT IN LINE
RQ=RQ-RR
IF(RQ.GE.0)GO TO 1402
C MOVE RIGHT ONE SCAN LINE FOR NEXT VECTOR
R3Q=R3Q+RA
RJX=RJX+RA
C R3Q AND RJX ARE THE 2 X COORDS.
RETURN
1402 RX=RX+RA
C MOVE UP ONE SCAN LINE FOR NEXT VECTOR
OLDY=OLDY+RA
C RX AND OLDY ARE THE 2 Y COORDS.
C GO DRAW IT
END
SUBROUTINE HBRACK
COMMON/STF/RSTFAC(0/7),RSTJ2
COMMON R2,JA,CENTR,J2,RJQ(20),JQ(16),RE,RF,DBR,RH/BM/RA,RC,RJY
COMMON/POSI/STFF(0/7),JJ2,POS/PLTR/PLT,RHT,DIS,XDIS
COMMON/ALF/QQ(3),RST7,RST18,R3Q,JY,RD,RX,RW,RJX,RJ,L,K,
1 RJA,YY,DISX,HGT,RZ,INP(53) /OLDTOP/OLDY
EQUIVALENCE (J4,JQ(2)),(R5,RJQ(3)),(R6,RJQ(4)),(R4,RJQ(2))
1401 R4=2.0
C FOR HEAVY BRACK.
RA=RST7
RX=RX-RA
C THE BOTTOM
L=J4+J2-1
R6=3.0
IF(L.LE.7)GO TO 4401
L=7
R6=300.
4401 RA=STFF(L)
C SAVE FOR POS. OF BRACK. END ON UPPER STAFF.
RJY=RSTFAC(L)
OLDY=RA+(R6+63.)*RJY
C THE TOP
R5=9.5
END
SUBROUTINE CBRACK
COMMON /STF/RSTFAC(0/7),RSTJ2
COMMON R2,JA,CENTR,J2,RJQ(20),JQ(16)
COMMON /POSI/STFF(0/7),JJ2,POS
COMMON /ALF/QQ(3),RST7,RST18,R3Q,JY,RD,RX,RW,RJX,RJ,L,K,
1 RJA,YY,DISX,HGT,RZ,INP(53) /OLDTOP/OLDY
EQUIVALENCE (J4,JQ(2)),(J5,JQ(3)),(R6,RJQ(4)),(J8,JQ(6))
1,(R8,RJQ(6)),(R7,RJQ(5)),(R4,RJQ(2))
J5=5
C FOR CURVY BRACKET. P8 CAN CHANGE WIDTH.
J4=J4+J2-1
R7=(.3136*RSTFAC(J4)+.0056*(STFF(J4)-STFF(J2)))/RSTJ2
C .0056=.0392/7.(THE MAGIC NUM FOR VERT SIZE OF BRACK.) .3136=8*.0392
C ADD DIST BETWEEN BOTTOM OF STAVES TO HEIGHT OF TOP STAFF
C ***** USE P8 FOR WIDTH FACTOR!! *****
J8=0
R6=R8
R8=0
IF(R6.EQ.0)R6=1.+R6/20.
JA=3
R4=2.3
C BECAUSE BRACK DOESN'T REALLY GO UP FROM 0 ?!?X*↑
CALL CLEFS
END
SUBROUTINE RPDOT
C PUTS IN DOTS ON DOUBLE-BAR REPEATS
IMPLICIT INTEGER(A-Q,S-Z)
REAL DIS,DISX,HGT,POS,CENTR,STFF,HGT1,XDIS
COMMON/STF/RSTFAC(0/7),RSTJ2
COMMON R2,JA,CENTR,J2,RJQ(20),JQ(16),RE,RF,DBR,RH/BM/RA,RC,RJY
COMMON/POSI/STFF(0/7),JJ2,POS/PLTR/PLT,RHT,DIS,XDIS
COMMON/ALF/QQ(3),RST7,RST18,R3Q,JY,RD,RX,RW,RJX,RJ,L,K,
1 RJA,YY,DISX,HGT,RZ,INP(53)
COMMON/DAT/RACNT(69),RDOT(17)
EQUIVALENCE (J3,JQ(1)),(J4,JQ(2)),(J5,JQ(3)),(R4,RJQ(2))
1,(J7,JQ(5)),(R3,RJQ(1))
L=J4
C SAVE J4 IN L UNTIL END
RJ=L/100
IF(RJ.EQ.0)RJ=6.*RSTJ2
C HEAVY BAR WILL BE 5 LINES WIDE.
RZ=R3
J4=0
C MUST BE 0 FOR DOTS IN 'NOTWRT'
IF(DBR.NE.0)GO TO 2
IF(J5.GT.3)J5=3
DBR=J5
2 J5=0
C J5=1 RPT ↑, =2 RPT ↑, =3 RPT ↑
RJA=RD*2.
C TO SPACE DOTS, NOT ACCURATE FOR VERY SMALL OR VERY LARGE SIZE FACTORS
JY=DBR
IF(DBR.LT.2)GO TO 8400
R3=RJA+RJ+RZ
7400 DO 3400 K=J2,MOD(L,100)+J2-1
C PUT DOTS ON ALL STAVES COVERED BY BAR LINE.
4 RSTJ2=RSTFAC(K)
POS=STFF(K)
R4=6
CALL CENTX
C SPACES DOTS OUT FROM BAR
CALL RDRAW(1,17.0,RDOT,RSTJ2,R3,CENTR+RSTJ2,RSTJ2)
C /DAT/+=69 ;EXTENDED FOR +65 TO +69 1/78
C GO GET THE DOT
R4=8
CALL CENTX
3400 CALL RDRAW(1,17.0,RDOT,RSTJ2,R3,CENTR+RSTJ2,RSTJ2)
JY=JY-1
IF(JY.LT.2)GO TO 4400
8400 R3=RZ-RJA-4.*RSTJ2
GO TO 7400
C DO I NEED ANY MORE RESETS????
4400 J4=L
J7=RJ*DIS
END